home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / prog / pas_all.zip / TI227.ASC < prev    next >
Text File  |  1991-09-11  |  9KB  |  463 lines
  1.  
  2.  
  3.  
  4.  
  5.  
  6.  
  7.  
  8.  
  9.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  10.   VERSION : 3.01
  11.        OS : MS-DOS, PC-DOS, CP/M-86
  12.      DATE : August 4, 1986                               PAGE : 1/7
  13.     TITLE : TRANSCENDENTAL FUNCTIONS
  14.  
  15.  
  16.  
  17.  
  18.   The following example routines are public domain programs that
  19.   have been uploaded to our Forum on CompuServe. As a courtesy to
  20.   our users that do not have immediate access to CompuServe,
  21.   Technical Support distributes these routines free of charge.
  22.  
  23.   However, because these routines are public domain programs, not
  24.   developed by Borland International, we are unable to provide any
  25.   technical support or assistance using these routines. If you need
  26.   assistance using these routines, or are experiencing
  27.   difficulties, we recommend that you log onto CompuServe and
  28.   request assistance from the Forum members that developed these
  29.   routines.
  30.  
  31.   Written by Randall A. Gacek
  32.  
  33.   This is a first approximation of a set of routines to do the
  34.   transcendental functions LOG, LN, SQRT, ARCTAN, SIN, COS and EXP
  35.   in the BCD version of Turbo Pascal.
  36.  
  37.   WARNING: The following code is specific to the implementation of
  38.   Turbo Pascal with BCD support. These functions should only be
  39.   used with this implementation.
  40.  
  41.   program checkfuncs;
  42.  
  43.   function sqrt(x:real):real;
  44.  
  45.   var
  46.     n,i,m :integer;
  47.     f,y   :real;
  48.     v     :record case boolean of
  49.               true:(y:real);
  50.              false:(z:array[1..10] of byte)
  51.             end;
  52.   begin
  53.     if x = 0.0 then
  54.       sqrt:=0.0
  55.     else if x < 0.0 then
  56.       halt
  57.     else begin
  58.       v.y:=x;
  59.       n:=v.z[1]-63;
  60.       v.z[1]:=63;
  61.  
  62.  
  63.  
  64.  
  65.  
  66.  
  67.  
  68.  
  69.  
  70.  
  71.  
  72.  
  73.  
  74.  
  75.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  76.   VERSION : 3.01
  77.        OS : MS-DOS, PC-DOS, CP/M-86
  78.      DATE : August 4, 1986                               PAGE : 2/7
  79.     TITLE : TRANSCENDENTAL FUNCTIONS
  80.  
  81.  
  82.  
  83.  
  84.       f:=v.y;
  85.       y:=0.580661+f/2.0-0.086462/(f+0.175241);
  86.       for i:=1 to 2 do
  87.         y:=0.5*(y+f/y);
  88.       y:=y+0.5*(f/y-y);
  89.       if odd(n) then
  90.       begin
  91.         y:=y*0.316227766016837933;
  92.         n:=n+1;
  93.       end;
  94.  
  95.   checkfuncs Con't.
  96.  
  97.       m:=n div 2;
  98.       v.y:=y;
  99.       v.z[1]:=v.z[1]+m;
  100.       sqrt:=v.y;
  101.     end;
  102.   end; { sqrt }
  103.  
  104.   function log(x:real):real;
  105.     const
  106.       c0= 0.316227766016837933;
  107.       a0=-0.260447002405557636E+2;
  108.       a1= 0.554085912041205931E+2;
  109.       a2=-0.392737410203156250E+2;
  110.       a3= 0.103338571514793865E+2;
  111.       a4=-0.741010784161919239E+0;
  112.       b0=-0.899552077881033117E+2;
  113.       b1= 0.245347618868489348E+3;
  114.       b2=-0.244303035341829542E+3;
  115.       b3= 0.107109789115668009E+3;
  116.       b4=-0.193732345832854786E+2;
  117.       c=  0.868588963806503655;
  118.  
  119.     var
  120.       n:integer;
  121.       xn,f,s,w,aw,bw,rs2,rs:real;
  122.       v:record case boolean of
  123.         true:(y:real);
  124.         false:(z:array[1..10] of byte)
  125.       end;
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  
  141.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  142.   VERSION : 3.01
  143.        OS : MS-DOS, PC-DOS, CP/M-86
  144.      DATE : August 4, 1986                               PAGE : 3/7
  145.     TITLE : TRANSCENDENTAL FUNCTIONS
  146.  
  147.  
  148.  
  149.  
  150.   begin
  151.     if x <= 0.0 then
  152.       halt;
  153.     v.y:=x;
  154.     n:=v.z[1]-63;
  155.     v.z[1]:=63;
  156.     f:=v.y;
  157.     if f <= c0 then
  158.     begin
  159.       n:=n-1;
  160.       f:=f*10.0;
  161.     end;
  162.  
  163.  
  164.   checkfuncs Con't.
  165.  
  166.     s:=((f-0.5)-0.5)/(f+1.0);
  167.     w:=sqr(s);
  168.     aw:= (((a4*w+a3)*w+a2)*w+a1)*w+a0;
  169.     bw:=((((w+b4)*w+b3)*w+b2)*w+b1)*w+b0;
  170.     rs2:=w*aw/bw;
  171.     rs:=s*(c+rs2);
  172.     xn:=n;
  173.     log:=xn+rs;
  174.   end; { log }
  175.  
  176.   function ln(x:real):real;
  177.     const
  178.       c3=2.30258509299404568;
  179.  
  180.   begin
  181.       ln:=log(x)*c3;
  182.   end;
  183.  
  184.   function exp(x:real):real;
  185.     const
  186.       bigx=147.365445951618923;
  187.       smallx=-145.062860858624878;
  188.       eps=5.0e-19;
  189.       onelnsqrt10=0.868588963806503655;
  190.       c1=1.151;
  191.       c2=2.92546497022842009e-4;
  192.       p0=0.333267029226801611e+6;
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  
  207.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  208.   VERSION : 3.01
  209.        OS : MS-DOS, PC-DOS, CP/M-86
  210.      DATE : August 4, 1986                               PAGE : 4/7
  211.     TITLE : TRANSCENDENTAL FUNCTIONS
  212.  
  213.  
  214.  
  215.  
  216.       p1=0.100974148724273918E+5;
  217.       p2=0.420414268137450315E+2;
  218.       q0=0.666534058453603223E+6;
  219.       q1=0.757393346159883444E+5;
  220.       q2=0.841243584514154545E+3;
  221.       sqrt10=3.16227766016837933;
  222.     var
  223.       n:integer;
  224.       xn,g,z,gpz,qz,rg:real;
  225.       v:record case boolean of
  226.         true:(y:real);
  227.         false:(z:array[1..10] of byte)
  228.         end;
  229.  
  230.   checkfuncs Con't.
  231.  
  232.   begin
  233.     if x > bigx then
  234.       halt;
  235.     if x < smallx then
  236.       halt;
  237.     if abs(x) < eps then
  238.       exp:=1.0
  239.     else begin
  240.       n:=round(x*onelnsqrt10);
  241.       xn:=n;
  242.       g:=(x-xn*c1)-xn*c2;
  243.       z:=sqr(g);
  244.       gpz:=((p2*z+p1)*z+p0)*g;
  245.       qz:= ((z+q2)*z+q1)*z+q0;
  246.       rg:=(0.5+gpz/(qz-gpz))*2.0;
  247.       if odd(n) then
  248.         if n >= 0 then
  249.           rg:=sqrt10*rg
  250.         else
  251.           rg:=rg/sqrt10;
  252.       n:=n div 2;
  253.       v.y:=rg;
  254.       v.z[1]:=v.z[1]+n;
  255.       exp:=v.y;
  256.     end;
  257.   end; { exp }
  258.  
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  274.   VERSION : 3.01
  275.        OS : MS-DOS, PC-DOS, CP/M-86
  276.      DATE : August 4, 1986                               PAGE : 5/7
  277.     TITLE : TRANSCENDENTAL FUNCTIONS
  278.  
  279.  
  280.  
  281.  
  282.   function sincos(x,y,sgn:real):real;
  283.     const
  284.       ymax=3141592654.0;
  285.       onepi=0.318309886183790672;
  286.       c1= 3.141;                  { pi to 22 digits }
  287.       c2= 0.000592653589793238463;
  288.       eps=1.0e-9;
  289.       r1=-0.166666666666666651e+0;
  290.       r2= 0.833333333333316503E-2;
  291.       r3=-0.198412698412018405E-3;
  292.       r4= 0.275573192101527561E-5;
  293.       r5=-0.250521067982745845E-7;
  294.       r6= 0.160589364903715891E-9;
  295.       r7=-0.764291780689104677E-12;
  296.       r8= 0.272047909578888462E-14;
  297.  
  298.   checkfuncs Con't.
  299.  
  300.     var
  301.       xn,f,t,g,rg:real;
  302.   begin
  303.     if y >= ymax then
  304.       halt;
  305.     xn:=y*onepi;
  306.     xn:=int(xn+0.5);
  307.     if frac(xn / 2.0) <> 0.0 then
  308.       sgn:=-sgn;
  309.     if abs(x) <> y then { cos wanted }
  310.       xn:=xn-0.5;
  311.     f:=(abs(x)-xn*c1)-xn*c2;
  312.     if abs(f) < eps then
  313.       t:=f
  314.     else begin
  315.       g:=sqr(f);
  316.       rg:=(((((((r8*g+r7)*g+r6)*g+r5)*g+r4)*g+r3)*g+r2)*g+r1)*g;
  317.       t:=f+f*rg;
  318.     end;
  319.     sincos:=sgn*t;
  320.   end; { sincos }
  321.  
  322.   function sin(x:real):real;
  323.   begin
  324.     if x < 0.0 then
  325.  
  326.  
  327.  
  328.  
  329.  
  330.  
  331.  
  332.  
  333.  
  334.  
  335.  
  336.  
  337.  
  338.  
  339.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  340.   VERSION : 3.01
  341.        OS : MS-DOS, PC-DOS, CP/M-86
  342.      DATE : August 4, 1986                               PAGE : 6/7
  343.     TITLE : TRANSCENDENTAL FUNCTIONS
  344.  
  345.  
  346.  
  347.  
  348.       sin:=sincos(x,-x,-1.0)
  349.     else
  350.       sin:=sincos(x,x,1.0);
  351.   end; {sin}
  352.  
  353.   function cos(x:real):real;
  354.   begin
  355.     cos:=sincos(x,abs(x)+1.57079632679489662,1.0);
  356.   end; {cos}
  357.  
  358.   checkfuncs Con't.
  359.  
  360.   function arctan(x:real):real;
  361.     const
  362.       twomsqrt3=0.267949192431122706;
  363.       sqrt3=1.73205080756887729;
  364.       a=0.732050807568877294;
  365.       eps=1e-9;
  366.       p0=-0.136887688941919269e+2;
  367.       p1=-0.205058551958616520e+2;
  368.       p2=-0.849462403513206835e+1;
  369.       p3=-0.837582993681500593e+0;
  370.       q0= 0.410663066825757813e+2;
  371.       q1= 0.861573495971302425e+2;
  372.       q2= 0.595784361425973445e+2;
  373.       q3= 0.150240011600285761e+1;
  374.  
  375.     var
  376.       n:integer;
  377.       f,result,g,gpg,qg,r:real;
  378.   begin
  379.     f:=abs(x);
  380.     if f > 1.0 then
  381.     begin
  382.       f:=1.0/f;
  383.       n:=2;
  384.     end
  385.     else
  386.       n:=0;
  387.     if f > twomsqrt3 then
  388.     begin
  389.       f:=(((a*f-0.5)-0.5)+f)/(sqrt3+f);
  390.       n:=n+1;
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  
  398.  
  399.  
  400.  
  401.  
  402.  
  403.  
  404.  
  405.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  406.   VERSION : 3.01
  407.        OS : MS-DOS, PC-DOS, CP/M-86
  408.      DATE : August 4, 1986                               PAGE : 7/7
  409.     TITLE : TRANSCENDENTAL FUNCTIONS
  410.  
  411.  
  412.  
  413.  
  414.     end;
  415.     if abs(f) < eps then
  416.       result:=f
  417.     else begin
  418.       g:=sqr(f);
  419.       gpg:=(((p3*g+p2)*g+p1)*g+p0)*g;
  420.       qg:=(((g+q3)*g+q2)*g+q1)*g+q0;
  421.       r:=gpg/qg;
  422.       result:=f+f*r;
  423.     end;
  424.     if n > 1 then
  425.       result:=-result;
  426.  
  427.   checkfuncs Con't.
  428.  
  429.     case n of
  430.       0:;
  431.       1:result:=0.523598775598298873+result;
  432.       2:result:=1.57079632679489662+result;
  433.       3:result:=1.04719755119659775+result;
  434.     end;
  435.     if x < 0.0 then
  436.       result:=-result;
  437.     arctan:=result;
  438.   end; { arctan }
  439.  
  440.   begin
  441.     writeln('sqrt= ',sqrt(25));
  442.     writeln('ln = ',ln(25));
  443.     writeln('exp = ',exp(25));
  444.     writeln('cos = ',cos(25));
  445.     writeln('sin = ',sin(25));
  446.     writeln('log = ',log(25));
  447.     writeln('arctan = ',arctan(25));
  448.   end.
  449.  
  450.  
  451.  
  452.  
  453.  
  454.  
  455.  
  456.  
  457.  
  458.  
  459.  
  460.  
  461.  
  462.  
  463.